home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / format.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  11KB  |  519 lines
  1. /* ******************************************************************** */
  2. /* format.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Formatted IO                               */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, June 1990
  10.  * $Id: format.c,v 1.5 1992/01/09 22:28:50 pab Exp $
  11.  *
  12.  * $Log: format.c,v $
  13.  * Revision 1.5  1992/01/09  22:28:50  pab
  14.  * Fixed for low tag ints
  15.  *
  16.  * Revision 1.4  1992/01/05  22:48:03  pab
  17.  * Minor bug fixes, plus BSD version
  18.  *
  19.  * Revision 1.3  1991/12/22  15:14:04  pab
  20.  * Xmas revision
  21.  *
  22.  * Revision 1.2  1991/09/11  12:07:11  pab
  23.  * 11/9/91 First Alpha release of modified system
  24.  *
  25.  * Revision 1.1  1991/08/12  16:49:35  pab
  26.  * Initial revision
  27.  *
  28.  * Revision 1.9  1991/02/13  18:19:31  kjp
  29.  * Altered format NOT to call allocate string.
  30.  *
  31.  * Revision 1.8  1990/12/18  14:32:09  jpff
  32.  * Binary Format fix
  33.  *
  34.  * Revision 1.7  90/12/18  14:27:28  jpff
  35.  * typo
  36.  * 
  37.  * Revision 1.6  90/12/18  14:25:34  jpff
  38.  * Improved e f and g formats, implemented b formay
  39.  * 
  40.  * Revision 1.5  90/12/18  14:06:47  jpff
  41.  * More on format
  42.  * 
  43.  * Revision 1.4  90/12/18  13:17:28  jpff
  44.  * Extra formats
  45.  * 
  46.  * Revision 1.3  90/12/18  12:27:29  jpff
  47.  * Added formats, and case labels for unimplemented stuff
  48.  * 
  49.  * Revision 1.2  90/11/23  16:36:05  is
  50.  * Added Id and Log fields
  51.  * Added ~u (for uniq) format specifier, which prints out nil or the hex
  52.  * address of the object
  53.  * 
  54.  */
  55.  
  56.  
  57. #include <string.h>
  58. #include <stdio.h>
  59. #include "funcalls.h"
  60. #include "defs.h"
  61. #include "structs.h"
  62. #include "error.h"
  63. #include "global.h"
  64.  
  65. #include "modboot.h"
  66. #include "symboot.h"
  67.  
  68. #include "ngenerics.h"
  69.  
  70. #include "sio.h" 
  71.  
  72. /*
  73.  
  74.  * O..
  75.  
  76.  */
  77.  
  78. LispObject format_to_string(LispObject *stacktop,
  79.                             LispObject format,LispObject list)
  80. {
  81.   char *walker = stringof(format);
  82.   int index;
  83.  
  84.   /* Hack using socket writer... */
  85.  
  86.   BUFFER_PTR() = 0;
  87.  
  88.   while (TRUE) {
  89.  
  90.     index = 0;
  91.  
  92.     while (*walker != '~' && *walker != '\0') {
  93.  
  94.       *(BUFFER()) = *walker;
  95.  
  96.       ++walker; ++index; ++(BUFFER_PTR());
  97.  
  98.     }
  99.  
  100.     if (*walker == '\0') {
  101.       
  102.       *(BUFFER()) = '\0';
  103.       
  104.       return((LispObject) 
  105.          allocate_string(stacktop,BUFFER_START(),strlen(BUFFER_START())));
  106.  
  107.     }
  108.  
  109.     ++walker;
  110.  
  111.     switch (*walker) {
  112.  
  113.     case '\0':
  114.       CallError(stacktop,"format: ~ at end of string",format,NONCONTINUABLE);
  115.       break;
  116.     case '~':
  117.       *(BUFFER()) = '~';
  118.       ++(BUFFER_PTR());
  119.       break;
  120.     case '%':
  121.       *(BUFFER()) = '\n';
  122.       ++(BUFFER_PTR());
  123.       break;
  124.     case 't':
  125.       *(BUFFER()) = '\t';
  126.       ++(BUFFER_PTR());
  127.       break;
  128.     case '|':
  129.       *(BUFFER()) = '\f';
  130.       ++(BUFFER_PTR());
  131.       break;
  132.     case 'a':
  133.       if (is_cons(list)) {
  134.     if (is_string(CAR(list))) {
  135.       strcpy(BUFFER(),stringof(CAR(list)));
  136.       BUFFER_PTR() += strlen(stringof(CAR(list)));
  137.     }
  138.     else {
  139.       write_object(stacktop,CAR(list));
  140.     }
  141.  
  142.     list = CDR(list);
  143.  
  144.       }
  145.       else {
  146.  
  147.     write_object(stacktop,nil);
  148.  
  149.       }
  150.       break;
  151.     default:
  152.       *(BUFFER()) = *walker;
  153.       ++(BUFFER_PTR());
  154.       break;
  155.  
  156.     }
  157.  
  158.     ++walker;
  159.   }
  160.  
  161.   return(nil);
  162. }
  163.  
  164. /* Lisp.. */
  165.  
  166. #define FORMAT_BUFFER_SIZE (512)
  167.  
  168. EUFUN_3( Fn_format, str, format, list)
  169. {
  170.   extern LispObject Gf_generic_prin(LispObject*);
  171.   extern LispObject Gf_generic_write(LispObject*);
  172.  
  173.   LispObject ostream,pstring;
  174.   char buffer[FORMAT_BUFFER_SIZE];
  175.   char *walker;
  176.   int index;
  177.  
  178.   if (!is_string(format))
  179.     CallError(stacktop,"format: not a string",format,NONCONTINUABLE);
  180.  
  181.   if (str == nil) return(format_to_string(stacktop,format,list));
  182.  
  183.   if (str == lisptrue) ostream = StdOut;
  184.   else ostream = str;
  185.  
  186.   if (!is_stream(ostream))
  187.     CallError(stacktop,"format: not a stream",ostream,NONCONTINUABLE);
  188.  
  189.   if (!is_string(format))
  190.     CallError(stacktop,"format: not a string",format,NONCONTINUABLE);
  191.  
  192.   /* Copy the string into the buffer until a tilda... */
  193.  
  194.   walker = stringof(format);
  195.  
  196.   while (TRUE) {
  197.  
  198.     index = 0;
  199.  
  200.     while (*walker != '~' && *walker != '\0') {
  201.  
  202.       if (index >= FORMAT_BUFFER_SIZE)
  203.     CallError(stacktop,
  204.           "format: out of buffer space",format,NONCONTINUABLE);
  205.  
  206.       buffer[index] = *walker;
  207.  
  208.       walker += 1; ++index;
  209.       
  210.     }
  211.  
  212.     buffer[index] = '\0';
  213.  
  214.     /* Output this string... */
  215.  
  216.     /*
  217.     STACK_TMP(ostream);
  218.     pstring = (LispObject) allocate_string(stacktop,buffer,index);
  219.     UNSTACK_TMP(ostream);
  220.     STACK_TMP(ostream);
  221.     EUCALL_2(Gf_generic_prin,pstring,ostream);
  222.     UNSTACK_TMP(ostream);
  223.     
  224.     */
  225.  
  226.     /* Cheat... */
  227.  
  228.     fprintf(ostream->STREAM.handle,"%s",buffer);
  229.  
  230.     if (*walker == '\0') {
  231.  
  232.       /* All done... */
  233.       return(nil);
  234.  
  235.     }
  236.  
  237.     /* We have a tilde modifier... */
  238.  
  239.     ++walker;
  240.  
  241.     list = ARG_2(stackbase);
  242.     format = ARG_1(stackbase);
  243.     switch (*walker) {
  244.  
  245.     case '\0': 
  246.       CallError(stacktop,"format: ~ at end of string",format,NONCONTINUABLE);
  247.       break;
  248.     case '~':
  249.       fprintf(ostream->STREAM.handle,"~");
  250.       break;
  251.     case '%':
  252.       fprintf(ostream->STREAM.handle,"\n");
  253.       break;
  254.     case 't':
  255.       fprintf(ostream->STREAM.handle,"\t");
  256.       break;
  257.     case '|':
  258.       fprintf(ostream->STREAM.handle,"\f");
  259.       break;
  260.     case 'a':
  261.       {
  262.     LispObject obj;
  263.  
  264.     if (is_cons(list)) {
  265.       obj = CAR(list);
  266.       ARG_2(stackbase) = list = CDR(list);
  267.     }
  268.     else obj = nil;
  269.  
  270.     STACK_TMP(ostream);
  271.     EUCALL_2(Gf_generic_prin,obj,ostream);
  272.     UNSTACK_TMP(ostream);
  273.  
  274.     break;
  275.       }
  276.     case 's':
  277.       {
  278.     LispObject obj;
  279.  
  280.     if (is_cons(list)) {
  281.       obj = CAR(list);
  282.       ARG_2(stackbase) = list = CDR(list);
  283.     }
  284.     else obj = nil;
  285.  
  286.     STACK_TMP(ostream);
  287.     EUCALL_2(Gf_generic_write,obj,ostream);
  288.     UNSTACK_TMP(ostream);
  289.  
  290.     break;
  291.       }
  292.     case 'u':
  293.       {
  294.     LispObject obj;
  295.  
  296.     if (is_cons(list)) {
  297.       obj = CAR(list);
  298.       ARG_2(stackbase) = list = CDR(list);
  299.     }
  300.     else obj = nil;
  301.  
  302.         fprintf(ostream->STREAM.handle,(obj==nil)?"nil":"#x%x",obj);
  303.  
  304.     break;
  305.       }
  306.     case 'c':            /* Print a character */
  307.       {
  308.     LispObject obj;
  309.  
  310.     if (is_cons(list)) {
  311.       obj = CAR(list);
  312.       ARG_2(stackbase) = list = CDR(list);
  313.     }
  314.     else obj = nil;
  315.     if (is_char(obj))
  316.       fprintf(ostream->STREAM.handle,"%c",obj->CHAR.code);
  317.     else
  318.       fprintf(ostream->STREAM.handle,"?");
  319.     break;
  320.       }
  321.     case 'd':            /* Print in decimal */
  322.       {
  323.     LispObject obj;
  324.  
  325.     if (is_cons(list)) {
  326.       obj = CAR(list);
  327.       ARG_2(stackbase) = list = CDR(list);
  328.     }
  329.     else obj = nil;
  330.     if (is_fixnum(obj))
  331.       fprintf(ostream->STREAM.handle,"%d",intval(obj));
  332.     else
  333.       fprintf(ostream->STREAM.handle,"<not-integer>");
  334.     break;
  335.       }
  336.     case 'o':            /* Print in octal */
  337.       {
  338.     LispObject obj;
  339.  
  340.     if (is_cons(list)) {
  341.       obj = CAR(list);
  342.       ARG_2(stackbase) = list = CDR(list);
  343.     }
  344.     else obj = nil;
  345.     if (is_fixnum(obj))
  346.       fprintf(ostream->STREAM.handle,"%o",intval(obj));
  347.     else
  348.       fprintf(ostream->STREAM.handle,"<not-integer>");
  349.     break;
  350.       }
  351.     case 'x':
  352.       {
  353.     LispObject obj;
  354.  
  355.     if (is_cons(list)) {
  356.       obj = CAR(list);
  357.       ARG_2(stackbase) = list = CDR(list);
  358.     }
  359.     else obj = nil;
  360.     if (is_fixnum(obj))
  361.       fprintf(ostream->STREAM.handle,"%x",intval(obj));
  362.     else
  363.       fprintf(ostream->STREAM.handle,"<not-integer>");
  364.     break;
  365.       }
  366.     case 'e':            /* Print in fpt E format */
  367.       { int n = 0, m = 0;
  368.     LispObject obj;
  369.  
  370.     if (is_cons(list)) {
  371.       obj = CAR(list);
  372.       ARG_2(stackbase) = list = CDR(list);
  373.     }
  374.     else obj = nil;
  375.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  376.     if (*walker == '.') {
  377.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  378.       if (is_float(obj))
  379.         fprintf(ostream->STREAM.handle,"%*.*E",m-n,n,intval(obj));
  380.       else
  381.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  382.       walker--;
  383.     }
  384.     else {
  385.       if (is_float(obj))
  386.         fprintf(ostream->STREAM.handle,"%E",intval(obj));
  387.       else
  388.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  389.       walker--;
  390.     }
  391.     break;
  392.       }
  393.     case 'f':            /* Print in fpt F format */
  394.       { int n = 0, m = 0;
  395.     LispObject obj;
  396.  
  397.     if (is_cons(list)) {
  398.       obj = CAR(list);
  399.       ARG_2(stackbase) = list = CDR(list);
  400.     }
  401.     else obj = nil;
  402.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  403.     if (*walker == '.') {
  404.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  405.       if (is_float(obj))
  406.         fprintf(ostream->STREAM.handle,"%*.*F",m-n,n,intval(obj));
  407.       else
  408.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  409.       walker--;
  410.     }
  411.     else {
  412.       walker--;
  413.       if (is_float(obj))
  414.         fprintf(ostream->STREAM.handle,"%F",intval(obj));
  415.       else
  416.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  417.     }
  418.     break;
  419.       }
  420.     case 'g':            /* Print in fpt G format */
  421.       { int n = 0, m = 0;
  422.     LispObject obj;
  423.  
  424.     if (is_cons(list)) {
  425.       obj = CAR(list);
  426.       ARG_2(stackbase) = list = CDR(list);
  427.     }
  428.     else obj = nil;
  429.     while (isdigit(*++walker)) m = 10 * m + *walker - '0';
  430.     if (*walker == '.') {
  431.       while (isdigit(*++walker)) n = 10 * n + *walker - '0';
  432.       if (is_float(obj))
  433.         fprintf(ostream->STREAM.handle,"%*.*G",m-n,n,intval(obj));
  434.       else
  435.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  436.       walker--;
  437.     }
  438.     else {
  439.       if (is_float(obj))
  440.         fprintf(ostream->STREAM.handle,"%G",intval(obj));
  441.       else
  442.         fprintf(ostream->STREAM.handle,"<not-floatinginteger>");
  443.       walker--;
  444.     }
  445.     break;
  446.       }
  447.     case 'b':            /* Print in binary */
  448.       {
  449.     LispObject obj;
  450.  
  451.     if (is_cons(list)) {
  452.       obj = CAR(list);
  453.       ARG_2(stackbase) = list = CDR(list);
  454.     }
  455.     else obj = nil;
  456.     if (is_fixnum(obj)) {
  457.       char bb[100];        /* WARNING: limit here */
  458.       char *p = bb;
  459.       int i = 0;
  460.       int n = intval(obj);
  461.       while (n!=0) {
  462.         *p++ = (n&1) + '0';
  463.         i++;
  464.         n >>=1;
  465.       }
  466.       for (p--; i>0; p--, i--) fprintf(ostream->STREAM.handle,"%c",*p);
  467.     }
  468.     else
  469.       fprintf(ostream->STREAM.handle,"<not-integer>");
  470.     break;
  471.       }
  472.     case 'p':            /* Prettyprint */
  473.     case '0': case '1': case '2': case '3': case '4':
  474.     case '5': case '6': case '7': case '8': case '9':
  475.     case '&':
  476.     default:
  477.       fprintf(ostream->STREAM.handle,"%c",*walker);
  478.  
  479.     }
  480.  
  481.     /* Lose character... */
  482.  
  483.     ++walker;
  484.  
  485.     /* Now, do it again... */
  486.  
  487.   }
  488.  
  489.   return(nil);
  490.  
  491. }
  492. EUFUN_CLOSE
  493.  
  494. /*
  495.  
  496.  * Module initialisation... 
  497.  
  498.  */
  499.  
  500. #define FORMATTED_IO_ENTRIES 1
  501. MODULE Module_formatted_io;
  502. LispObject Module_formatted_io_values[FORMATTED_IO_ENTRIES];
  503.  
  504. void initialise_formatted_io(LispObject *stacktop)
  505. {
  506.   BUFFER_START() = (char *)malloc(SOCKET_BUFFER_SIZE);
  507.  
  508.   open_module(stacktop,
  509.           &Module_formatted_io,
  510.           Module_formatted_io_values,
  511.           "formatted-io",
  512.           FORMATTED_IO_ENTRIES);
  513.  
  514.   (void) make_module_function(stacktop,"format",Fn_format,-3);
  515.  
  516.   close_module();
  517. }
  518.  
  519.